home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / braid.lsp < prev    next >
Lisp/Scheme  |  1992-08-12  |  35KB  |  847 lines
  1. ;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27. ;;; Bootstrapping the meta-braid.
  28. ;;;
  29. ;;; The code in this file takes the early definitions that have been saved
  30. ;;; up and actually builds those class objects.  This work is largely driven
  31. ;;; off of those class definitions, but the fact that STANDARD-CLASS is the
  32. ;;; class of all metaclasses in the braid is built into this code pretty
  33. ;;; deeply.
  34. ;;;
  35. ;;; 
  36.  
  37. (in-package 'pcl)
  38.  
  39. (defun early-class-name (class)
  40.   (bootstrap-get-slot 'class class 'name))
  41.  
  42. (defun early-class-definition (class-name)
  43.   (or (find class-name *early-class-definitions* :key #'ecd-class-name)
  44.       (error "~S is not a class in *early-class-definitions*." class-name)))
  45.  
  46. (defun canonical-slot-name (canonical-slot)
  47.   (getf canonical-slot :name))
  48.  
  49. (defun early-collect-inheritance (class-name)
  50.   (declare (values slots cpl default-initargs direct-subclasses))
  51.   (let ((cpl (early-collect-cpl class-name)))
  52.     (values (early-collect-slots cpl)
  53.         cpl
  54.         (early-collect-default-initargs cpl)
  55.         (gathering1 (collecting)
  56.           (dolist (definition *early-class-definitions*)
  57.         (when (memq class-name (ecd-superclass-names definition))
  58.           (gather1 (ecd-class-name definition))))))))
  59.  
  60. (defun early-collect-cpl (class-name)
  61.   (labels ((walk (c)
  62.          (let* ((definition (early-class-definition c))
  63.             (supers (ecd-superclass-names definition)))
  64.            (cons c
  65.              (apply #'append (mapcar #'early-collect-cpl supers))))))
  66.     (remove-duplicates (walk class-name) :from-end nil :test #'eq)))
  67.  
  68. (defun early-collect-slots (cpl)
  69.   (let* ((definitions (mapcar #'early-class-definition cpl))
  70.      (super-slots (mapcar #'ecd-canonical-slots definitions))
  71.      (slots (apply #'append (reverse super-slots))))
  72.     (dolist (s1 slots)
  73.       (let ((name1 (canonical-slot-name s1)))
  74.     (dolist (s2 (cdr (memq s1 slots)))
  75.       (when (eq name1 (canonical-slot-name s2))
  76.         (error "More than one early class defines a slot with the~%~
  77.                     name ~S.  This can't work because the bootstrap~%~
  78.                     object system doesn't know how to compute effective~%~
  79.                     slots."
  80.            name1)))))
  81.     slots))
  82.  
  83. (defun early-collect-default-initargs (cpl)
  84.   (let ((default-initargs ()))
  85.     (dolist (class-name cpl)
  86.       (let ((definition (early-class-definition class-name)))
  87.     (dolist (option (ecd-other-initargs definition))
  88.       (unless (eq (car option) :default-initargs)
  89.         (error "The defclass option ~S is not supported by the bootstrap~%~
  90.                     object system."
  91.            (car option)))
  92.       (setq default-initargs
  93.         (nconc default-initargs (reverse (cdr option)))))))
  94.     (reverse default-initargs)))
  95.  
  96.  
  97. ;;;
  98. ;;; bootstrap-get-slot and bootstrap-set-slot are used to access and change
  99. ;;; the values of slots during bootstrapping.  During bootstrapping, there
  100. ;;; are only two kinds of objects whose slots we need to access, CLASSes
  101. ;;; and SLOT-DEFINITIONs.  The first argument to these functions tells whether the
  102. ;;; object is a CLASS or a SLOT-DEFINITION.
  103. ;;;
  104. ;;; Note that the way this works it stores the slot in the same place in
  105. ;;; memory that the full object system will expect to find it later.  This
  106. ;;; is critical to the bootstrapping process, the whole changeover to the
  107. ;;; full object system is predicated on this.
  108. ;;;
  109. ;;; One important point is that the layout of standard classes and standard
  110. ;;; slots must be computed the same way in this file as it is by the full
  111. ;;; object system later.
  112. ;;; 
  113. (defun bootstrap-get-slot (type object slot-name)
  114.   (let ((index (bootstrap-slot-index type slot-name)))
  115.     (svref (std-instance-slots object) index)))
  116.  
  117. (defun bootstrap-set-slot (type object slot-name new-value)
  118.   (let ((index (bootstrap-slot-index type slot-name)))
  119.     (setf (svref (std-instance-slots object) index) new-value)))
  120.  
  121. (defvar *early-class-slots* nil)
  122.  
  123. (defun early-class-slots (class-name)
  124.   (cdr (or (assoc class-name *early-class-slots*)
  125.        (let ((a (cons class-name
  126.               (mapcar #'canonical-slot-name
  127.                   (early-collect-inheritance class-name)))))
  128.          (push a *early-class-slots*)
  129.          a))))
  130.  
  131. (defun early-class-original-static-slot-storage-copy (class-name)
  132.   (%allocate-origional-static-slot-storage-copy
  133.     (length (the list (early-class-slots class-name)))))
  134.  
  135. (defun bootstrap-slot-index (class-name slot-name)
  136.   (or (posq slot-name (the list (early-class-slots class-name)))
  137.       (error "~S not found" slot-name)))
  138.  
  139.  
  140. ;;;
  141. ;;; bootstrap-meta-braid
  142. ;;;
  143. ;;; This function builds the base metabraid from the early class definitions.
  144. ;;;   
  145. (defun bootstrap-meta-braid ()
  146.   (let* ((slot-class-original-slot-copy
  147.            (early-class-original-static-slot-storage-copy 'slot-class))
  148.      (standard-class-original-slot-copy
  149.            (early-class-original-static-slot-storage-copy 'standard-class))
  150.      (built-in-class-original-slot-copy
  151.            (early-class-original-static-slot-storage-copy 'built-in-class))
  152.      (structure-class-original-slot-copy
  153.            (early-class-original-static-slot-storage-copy 'structure-class))
  154.          (slot-class      (%allocate-instance--class standard-class-original-slot-copy))
  155.          (standard-class  (%allocate-instance--class standard-class-original-slot-copy))
  156.          (built-in-class  (%allocate-instance--class standard-class-original-slot-copy))
  157.          (structure-class (%allocate-instance--class standard-class-original-slot-copy))
  158.      (direct-slotd    (%allocate-instance--class standard-class-original-slot-copy))
  159.      (effective-slotd (%allocate-instance--class standard-class-original-slot-copy))
  160.      (class-eq        (%allocate-instance--class standard-class-original-slot-copy))
  161.      (slot-class-wrapper      (make-wrapper slot-class))
  162.      (standard-class-wrapper  (make-wrapper standard-class))
  163.      (built-in-class-wrapper  (make-wrapper built-in-class))
  164.      (structure-class-wrapper (make-wrapper structure-class))
  165.      (direct-slotd-wrapper    (make-wrapper direct-slotd))
  166.      (effective-slotd-wrapper (make-wrapper effective-slotd))
  167.      (class-eq-wrapper        (make-wrapper class-eq)))
  168.     ;;
  169.     ;; First, make a class metaobject for each of the early classes.  For
  170.     ;; each metaobject we also set its wrapper.  Except for the class T,
  171.     ;; the wrapper is always that of STANDARD-CLASS.
  172.     ;; 
  173.     (dolist (definition *early-class-definitions*)
  174.       (let* ((name (ecd-class-name definition))
  175.          (meta (ecd-metaclass definition))
  176.          (original-slot-copy
  177.                (ecase meta
  178.          (slot-class slot-class-original-slot-copy)
  179.          (standard-class standard-class-original-slot-copy)
  180.          (built-in-class built-in-class-original-slot-copy)
  181.          (structure-class structure-class-original-slot-copy)))
  182.              (class (case name
  183.               (slot-class                         slot-class)
  184.                       (standard-class                     standard-class)
  185.                       (standard-direct-slot-definition    direct-slotd)
  186.               (standard-effective-slot-definit